home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Hardcore Visual Basic 5.0 (2nd Edition)
/
Hardcore Visual Basic 5.0 - Second Edition (1997)(Microsoft Press).iso
/
Code
/
sysmenu.cls
< prev
next >
Wrap
Text File
|
1997-06-14
|
5KB
|
174 lines
VERSION 1.0 CLASS
BEGIN
MultiUse = -1 'True
END
Attribute VB_Name = "CSysMenu"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = True
Option Explicit
Implements ISubclass
Public Event MenuClick(sItem As String, ByVal ID As Long)
Public Enum EErrorSysMenu
eeBaseSysMenu = 13240 ' CSysMenu
eeHandleNotInit ' Handle not initialized
eeTooManyItems ' Too many menu items
eeNoSysWindow ' Can't get system window
End Enum
Private hWnd As Long, hSysMenu As Long
Private idCur As Long
Private emr As EMsgResponse, pOldProc As Long
Private Const idFirst As Long = 2000
Private Const cMaxItem = 10
Private Type TItem
sText As String
ID As Long
End Type
' Anyone putting too many items on system menu deserves rude errors
Private aItem(1 To cMaxItem + 1) As TItem
#If fComponent = 0 Then
Private Sub ErrRaise(e As Long)
Dim sText As String, sSource As String
If e > 1000 Then
sSource = App.ExeName & ".CSysMenu"
Select Case e
Case eeHandleNotInit
sText = "Add/RemoveItem: Handle not initialized"
Case eeTooManyItems
sText = "AddItem: Too many menu items"
Case eeNoSysWindow
sText = "Create: Can't get system window"
End Select
Err.Raise e Or vbObjectError, sSource, sText
Else
' Raise standard Visual Basic error
Err.Raise e, sSource
End If
End Sub
#End If
Private Sub Class_Initialize()
idCur = idFirst
End Sub
Private Sub Class_Terminate()
Destroy
End Sub
Sub Create(hWndA As Long)
' Get handle of system menu
hSysMenu = GetSystemMenu(hWndA, 0&)
If hSysMenu = hNull Then ErrRaise eeNoSysWindow
hWnd = hWndA
AttachMessage Me, hWndA, WM_SYSCOMMAND
End Sub
Sub Destroy()
Dim i As Integer
' Remove all the menu items
i = 1
Do While aItem(i).ID
Call RemoveMenu(hSysMenu, aItem(i).ID, MF_BYCOMMAND)
i = i + 1
Loop
DetachMessage Me, hWnd, WM_SYSCOMMAND
hWnd = hNull
End Sub
Property Get Identifier(i As Integer) As Long
Identifier = aItem(i).ID
End Property
Property Get Text(i As Integer) As String
Text = aItem(i).sText
End Property
Function AddItem(sItem As String) As Long
If hWnd = hNull Then
ErrRaise eeHandleNotInit
End If
' Append the new menu item or separator
idCur = idCur + 10
If sItem = sEmpty Or sItem = "-" Then
Call AppendMenu(hSysMenu, MF_SEPARATOR Or MF_BYCOMMAND, idCur, 0&)
Else
Call AppendMenu(hSysMenu, MF_BYCOMMAND, idCur, sItem)
End If
' Insert item
Dim i As Integer
For i = 1 To cMaxItem
If aItem(i).ID = 0 Then
aItem(i).ID = idCur
aItem(i).sText = sItem
AddItem = idCur
Exit Function
End If
Next
ErrRaise eeTooManyItems
End Function
Sub RemoveItem(ID As Long)
If hWnd = hNull Then
ErrRaise eeHandleNotInit
End If
' Find item, remove it, overwrite it
Dim f As Boolean, i As Integer, fDeleting As Boolean
i = 1
For i = 1 To cMaxItem
' Remove reference from vector
If aItem(i).ID = ID Then
f = RemoveMenu(hSysMenu, ID, MF_BYCOMMAND)
fDeleting = True
End If
' Overwrite deleted item
If fDeleting Then
aItem(i).ID = aItem(i + 1).ID
aItem(i).sText = aItem(i + 1).sText
End If
Next
End Sub
' Interface window procedure method
Private Function ISubclass_WindowProc(ByVal hWnd As Long, _
ByVal iMsg As Long, _
ByVal wParam As Long, _
ByVal lParam As Long) As Long
' Assume original WindowProc will handle
emr = emrPostProcess
' Subclasser should never call unless it's our message
BugAssert iMsg = WM_SYSCOMMAND
' Ignore everything except system commands
If wParam <= 3000 Then
' Check IDs and raise event if found
Dim i As Long
For i = 1 To cMaxItem
If aItem(i).ID = 0 Then Exit For
If wParam = aItem(i).ID Then
RaiseEvent MenuClick(aItem(i).sText, aItem(i).ID)
' We've finished so original WindowProc not needed
emr = emrConsume
Exit Function
End If
Next
End If
End Function
' Interface properties
Private Property Get ISubclass_MsgResponse() As EMsgResponse
ISubclass_MsgResponse = emr
End Property
Private Property Let ISubclass_MsgResponse(ByVal emrA As EMsgResponse)
emr = emrA
End Property
'